perm filename SC2.LSP[NEW,LSP] blob
sn#461087 filedate 1979-07-26 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 Documentation
C00008 00003 Load up files for compilation
C00009 00004 writeread, readNameOrPosition, GetAtom, find, validinstr, standard-instr
C00013 00005 field-names, get-field-type, name, flatten, go-back
C00016 00006 write-back-up
C00017 00007 create-new-object, edit-position, edit-orientation
C00021 00008 edit-uvars-ucons
C00026 00009 write-model-file and related functions
C00037 00010 M O D I T O R
C00042 00011 E D I T - S C E N E - O B J E C T
C00049 00012 E D I T - S U B P A R T S - T R E E
C00054 00013 E D I T - F I E L D
C00058 00014 E D I T - R E C O R D
C00065 00015 E D I T - S I M P L E
C00074 ENDMK
C⊗;
;Documentation
;see MODITO.DOC [ACR,HAW]
;also MANUAL [ACR,SEK]
; more details --> HAW or ROD
;;;Load up files for compilation
(EVAL-WHEN (COMPILE)
(OR (BOUNDP '|.loaded.|) (FASLOAD LOADER FAS DSK (SYS ROD)))
(LOADUP (RECORD FAS DSK (SYS ROD))
(USEDEC LSP DSK (SYS ROD))
(DECLAR LSP DSK (SYS ROD))
(GRAPHS LSP DSK (SYS ROD))
))
(EVAL-WHEN (COMPILE EVAL)
(SETQ %%RUNTIME-ERROR-CHECKS%% T))
(DECLARE (SPECIAL $GO-UP-NAME $GO-UP-LEVELS $NOVICE))
;writeread, readNameOrPosition, GetAtom, find, validinstr, standard-instr
;-----------------------------------------------------------------
;Writes the value x and reads the new value that replaces x.
(defun writeread (x)
(tyi)(tyi)
(ptload (exploden x))
(read))
;-----------------------------------------------------------------
;Allows the user to choose one of a list of possibilities:
; the user can specify the choice either by number or by name.
(defun readNameOrPosition (list)
(let input ← (read)
do
(if (numberp input) then
(if (< input 1) then
(writeln '| | input '| is not a valid position|) nil
else
(getAtom input list))
else (find input list))))
;-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
;Returns the positionth element of list.
(defun GetAtom (position list)
(cond ((null list)
(writeln '| Position is not valid - too large|) nil)
((= position 1) (car list))
((getAtom (1- position) (cdr list)))))
;-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
;Returns the list element which has the name this-name.
(defun find (this-name list)
(cond ((null list)
(writeln '| | this-name '| is not in the list of possibilities|) nil)
((eq this-name (name (car list)))(car list))
((find this-name (cdr list)))))
;-----------------------------------------------------------------
;Checks if the instruction is one of the standard instructions. If so, the
; proper function is executed. If not it must be one of the valid instructions
; in instr-list or an error message is written.
(defun validinstr (instruction instr-list)
(cond ((member instruction '(? E W x U)) (standard-instr instruction) nil)
((member instruction instr-list) instruction)
(T (writeln '| | instruction '| is not a valid instruction type|) nil)))
;-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
;Performs any standard instruction that is able to be called from any point
; in the editor;
(defun standard-instr (instruction)
(caseq instruction
(E (setq $novice nil))
(? (setq $novice t))
(W (write-model-file (read)))
(x (write-back-up))
(U (edit-ucons-uvars))))
;field-names, get-field-type, name, flatten, go-back
;-----------------------------------------------------------------
;Returns the list of the field names which are used by a given record type.
(defun field-names (record-type)
(cadr (assoc record-type $fields)))
;-----------------------------------------------------------------
;If a field has been declared to be of a certain record type,
; then this function returns the name of its record class (type).
(defun get-field-type (field-name record-type)
(let type ←
(assq 'record (cdr (assq field-name (caddr (assq record-type $fields)))))
do
(if (null type) then
(assq 'list-of-records
(cdr (assq field-name (caddr (assq record-type $fields))))) else type)))
;-----------------------------------------------------------------
;For printing references to a record that is a list.
; It selects one specific atom of the list.
(defun name (instance)
(let type ← (record-name instance)
do
(cond
((atom instance) instance)
((eq type 'scene-obj) ∂scene-obj:object[instance])
((eq type 'affixment) ∂affixment:inf[instance])
((eq type 'sub-cone ) ∂sub-cone:sub[instance]))))
;-----------------------------------------------------------------
(defun flatten (list)
(cond ((null list) nil)
((atom list) (list list))
((atom (car list)) (cons (car list) (flatten (cdr list))))
((append (flatten (car list)) (flatten (cdr list))))))
;-----------------------------------------------------------------
;Used for backing up. The global variables $go-up-name and $go-up-levels
; are set.
(defun go-back ()
(let name ← (read)
do
(if (numberp name) then
(setq $go-up-name 'no-go-back-name)
(setq $go-up-levels name)
else
(setq $go-up-name name)
(setq $go-up-levels 99))))
;write-back-up
(defun write-back-up ()
(write '| Maximum number of levels to write out (* for all) : |)
(let maxlevels ← (read)
do
(writeln)
(write-level $back-up-list 1
(if (numberp maxlevels) then maxlevels else 99))))
(defun write-level (back-up-list count max)
(if (not (or (null back-up-list) (> count max))) then
(write '| | count '| |)
(mapcar (function (lambda (x)
(write x '| |)))
(car back-up-list))
(writeln)
(write-level (cdr back-up-list) (add1 count) max)))
;create-new-object, edit-position, edit-orientation
;-----------------------------------------------------------------
;Creates a new object. This object is a rectangle with dimensions that
; are given by parameter dimensions.
(defun create-new-object (object-name dimensions)
(create object self object-name
cone-descriptor (create cone
main-cone (create simple-cone
spine (create spine type 'straight length (caddr dimensions))
sweeping-rule (create sweeping-rule type 'constant)
cross-section (create cross-section
type 'rectangle width (cadr dimensions)
height (car dimensions))))))
;-----------------------------------------------------------------
;Edits a position record (which may need to be created).
(defun edit-position (pos-instance)
(let instance ← (if (null pos-instance) then
(create position)
else pos-instance)
do
(writeln) (write '|POSITION : |)
(let pos ← (writeread ∂position:symbolic[instance])
do
(if (not (pos-validp pos)) then
(writeln '| | pos '| is not a valid position|)
else
∂position:symbolic[instance] ← pos
(pos-create-demon instance)
(putprop $current-simple-cone t 'changed-part)
(refresh '(draw-current-scene 'dd))))
instance))
;-----------------------------------------------------------------
;Edits a rotation record (which may need to be created) for an orientation.
(defun edit-orientation (ori-instance)
(let instance ← (if (null ori-instance) then
(create rotation)
else ori-instance)
do
(writeln) (write '|ORIENTATION : |)
(let ori ← (writeread ∂rotation:symbolic[instance])
do
(if (not (rot-validp ori)) then
(writeln '| | ori '| is not a valid orientation|)
else
∂rotation:symbolic[instance] ← ori
(rot-create-demon instance)
(putprop $current-simple-cone t 'changed-part)
(refresh '(draw-current-scene 'dd))))
instance))
;edit-uvars-ucons
(defun edit-ucons-uvars ()
(setq $back-up-list (cons '(USER-DEFINED VARIABLES AND CONSTANTS) $back-up-list))
(setq $go-up-name 'uvars-ucons)
(do nil ((and (not (eq $go-up-name 'uvars-ucons)) (> $go-up-levels 0))
(setq $back-up-list (cdr $back-up-list))
(setq $go-up-levels (1- $go-up-levels)) nil)
(setq $go-up-levels 0)
(writeln)
(writeln '|USER-DEFINED CONSTANTS AND VARIABLES :|)
(writeln)
(writeln '| User-Constants : | ∂db-index:ucons[$DB-INDEX])
(writeln '| User-Variables : | ∂db-index:uvars[$DB-INDEX])
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(write '| Go to field G <name> ? : |)
else
(write '| (?;B,G) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G)) then
(caseq instruction
(B (go-back))
(t
(let field ← (readNameOrPosition '(user-constants user-variables))
do (if field then
(caseq instruction
(G (edit-ucon-uvar-list
(if (eq field 'user-constants) then 'ucon
else 'uvar)))
)))))))))
(defun edit-ucon-uvar-list (type)
(setq $go-up-name nil)
(do nil ((and (not (eq $go-up-name nil)) (> $go-up-levels 0))
(setq $go-up-levels (1- $go-up-levels)) nil)
(setq $go-up-levels 0)
(let var-list ← (if (eq type 'ucon) then ∂db-index:ucons[$db-index]
else ∂db-index:uvars[$db-index])
do
(writeln)
(writeln '|This field is a list of the following elements : | var-list)
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(writeln '| Go to element G <name>|)
(writeln '| Add element A <name>|)
(write '| Delete element D <name> ? : |)
else
(write '| (?;B,G,A,D) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G A D)) then
(caseq instruction
(B (go-back))
(A (let name ← (read)
do
(writeln) (write '|VALUE : |)
(let value ← (writeread nil)
do
(create ≡type self name symbolic value))))
(t
(let element ← (readNameOrPosition var-list)
do (if element then
(caseq instruction
(G (writeln) (write '|VALUE : |)
(let value ← (writeread ∂≡type:symbolic[element])
do
∂≡type:symbolic[element] ← value
(if (eq type 'ucon) then (ucon-create-demon element)
else (uvar-create-demon element))))
(D (setq var-list (delq element var-list))
(case-delete-record type of $edited-record-types element))
))))))))))
;write-model-file and related functions
;-----------------------------------------------------------------
;Write-model-file writes out the model file in a form that is readable
; by the parser. The file name is specified by fname.
(defun write-model-file (fname)
(let filename ← (make-good-file-spec fname 'mod $user-dir)
then file ← (open filename 'out)
↑w ← t
↑r ← t
then outfiles ← (list file)
do
(write-uvars-ucons)
(for scene-object ε ∂scene:scene-list[$current-scene] do
(let object ← ∂scene-obj:object[scene-object] do
(setq $writelist nil)
(write-subparts object)
(writeln) (writeln)
(writeln '|(put | ∂scene-obj:object[scene-object] '|)|)
(write-affixments object)
(write-list)
(writeln) (writeln)))
(close file)))
;-----------------------------------------------------------------
;Write-ucons-uvars writes out each user constant and user variable
; found in $db-index with its symbolic value.
(defun write-uvars-ucons ()
(for ucon ε ∂db-index:ucons[$db-index] do
(writeln '|(USER-CONSTANT | ucon '| |
∂ucon:symbolic[ucon] '|)|))
(writeln)
(for uvar ε ∂db-index:uvars[$db-index] do
(writeln '|(USER-VARIABLE | uvar '| |
∂uvar:symbolic[uvar] '|)|))
(writeln) (writeln))
;-----------------------------------------------------------------
;Write-subparts writes out all subpart relations by traversing the
; subparts tree.
(defun write-subparts (instance)
(write '|(define object | instance '| having|)
(let cone-desc ← ∂object:cone-descriptor[instance] do
(if (not (null cone-desc)) then
(setq $writelist (cons cone-desc $writelist))
(write '| cone-descriptor | cone-desc)))
(for subpart ε ∂object:subparts[instance] do
(writeln)
(write '| subpart | subpart))
(writeln '|)|)
(mapcar 'write-subparts ∂object:subparts[instance]))
;-----------------------------------------------------------------
;Write-affixments writes out all affixment relations by traversing the
; subparts tree.
(defun write-affixments (instance)
(for affixment ε ∂object:affixments[instance] do
(write '|(affix | ∂affixment:inf[affixment]
'| to | ∂affixment:sup[affixment])
(let pos ← ∂affixment:position[affixment]
ori ← ∂affixment:orientation[affixment]
then
pos-sym ← ∂position:symbolic[pos]
ori-sym ← ∂rotation:symbolic[ori]
do
(if (or pos-sym ori-sym) then (write '| with|)
(if pos-sym then
(write '| pos|)
(for posi ε pos-sym do
(write '| | posi)))
(if ori-sym then
(write '| ori|)
(for orii ε ori-sym do
(write '| | orii)))
))
(writeln '|)|))
(mapcar 'write-affixments ∂object:subparts[instance]))
;-----------------------------------------------------------------
;Write-record writes out one record in ASCII. Every field-name is printed
; followed by its value.
;If the field value is a record with a user-defined name (i.e. not a 'Z'
; with four digits), only its name is written out and it is concatenated
; to a list $writelist. Otherwise, write-record is called to write out
; the record's fields.
(defun write-record (instance indentation)
(let record-type ← (record-name instance)
then
recordname ← (if (atom instance) then instance
else ∂≡record-type:self[instance])
fieldnames ← (delq 'sub-cones (delq 'affixments (delq 'obs-graph
(delq 'name (delq 'subparts (α-copy (field-names record-type)))))))
do
(if (member 'type fieldnames) then
(let type ← ∂≡record-type:type[instance]
do
(if (null type) then (setq fieldnames '())
else (setq fieldnames
(cons 'type (cdr (assoc type (assoc record-type $variants))))))))
(write '|(define | record-type)
(if (not (gensymp recordname)) then (write '| | recordname))
(writeln '| having |)
(for field-name ε fieldnames do
(let field-instance ← ∂≡record-type:≡field-name[instance]
field-type ← (cdr (get-field-type field-name record-type))
do
(indent indentation)
(write field-name '| |)
(cond
((null field-type) (writeln field-instance))
((eq field-type 'complex-filler)
(writeln field-instance))
((not (gensymp field-instance))
(writeln field-instance)
(setq $writelist (cons field-instance $writelist)))
(t (write-record field-instance (+ 1 indentation))))))
(indent indentation) (writeln '|)|)
(if (member 'sub-cones (α-copy (field-names record-type))) then
(for sub-cone ε ∂≡record-type:sub-cones[instance] do
(writeln)
(indent (- 1 indentation))
(write '|(sub-cone |)
(write-record ∂sub-cone:sub[sub-cone] indentation)
(indent (+ 1 indentation))
(write '|of | recordname)
(let pos ← ∂sub-cone:position[sub-cone]
ori ← ∂sub-cone:orientation[sub-cone]
then
pos-sym ← ∂position:symbolic[pos]
ori-sym ← ∂rotation:symbolic[ori]
do
(if (or pos-sym ori-sym) then (write '| with|)
(if pos-sym then
(write '| pos|)
(for posi ε pos-sym do
(write '| | posi)))
(if ori-sym then
(write '| ori|)
(for orii ε ori-sym do
(write '| | orii)))))
(writeln '|)|)))
))
;-----------------------------------------------------------------
;Write-list calls write-record to define records put on $writelist.
; All records are marked when they are defined to avoid repetition.
(defun write-list ()
(if (not (null $writelist)) then
(let instance ← (car $writelist) do
(setq $writelist (cdr $writelist))
(if (and instance (not (get instance 'marked))) then
(writeln)(writeln)
(putprop instance t 'marked)
(write-record instance 1))
(write-list)
(putprop instance nil 'marked))))
;-----------------------------------------------------------------
;Returns true if name is a system-generated name (i.e. a 'Z' with four digits).
(defun gensymp (name)
(let letters ← (exploden name)
do
(if (= (car letters) 90) then
(gen1 (cdr letters) 0)
else nil)))
(defun gen1 (letters count)
(cond ((null letters) (eq count 4))
((and (< 47 (car letters)) (> 58 (car letters)))
(gen1 (cdr letters) (add1 count)))
(t nil)))
(defun indent (number)
(if (> number 0) then (write '| |) (indent (1- number))))
;M O D I T O R
; The highest level function.
; First thing to do is to decide which object in the current scene to
; look at.
(defun MODITOR ()
(setq $novice nil)
(setq $go-up-levels 0)
(setq $current-simple-cone 'dummy)
(second-monitor)(get-dd-chan)
(refresh '(draw-current-scene 'dd))
(setq $back-up-list (list '(scene)))
(setq $go-up-name 'scene)
(do nil ((and (not (eq $go-up-name 'scene)) (> $go-up-levels 0))
(setq $back-up-list nil)
(setq $go-up-levels (1- $go-up-levels)) '*)
(setq $go-up-levels 0)
(let scene-objects ← ∂scene:scene-list[$current-scene]
do
(writeln)
(writeln '|SCENE ----> | (mapcar 'name scene-objects))
(writeln)
(if $novice then
(writeln '| Quit editing B *|)
(writeln '| Jump to object G <name>|)
(writeln '| Add new object A <name>|)
(writeln '| Remove object R <name>|)
(writeln '| Kill object K <name>|)
(write '| Delete object D <name> ? : |)
else
(write '| (?;B,G,A,R,K,D) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G A R K D)) then
(caseq instruction
(B (read)(return '*))
(A (let scene-name ← (create scene-obj
scene $current-scene
object (create-new-object (read) '(15.0 20.0 30.0)))
do
∂scene:scene-list[$current-scene] ↓ scene-name
(refresh '(draw-current-scene 'dd))
(edit-scene-object scene-name)))
(t
(let name ← (readNameOrPosition scene-objects)
do (if name then
(caseq instruction
(G (if (is? scene-obj name) then (edit-scene-object name)))
(R ∂scene:scene-list[$current-scene] ←
(delq name ∂scene:scene-list[$current-scene]))
(D ∂scene:scene-list[$current-scene] ←
(delq name ∂scene:scene-list[$current-scene])
(refresh '(draw-current-scene 'dd)))
(K ∂scene:scene-list[$current-scene] ←
(delq name ∂scene:scene-list[$current-scene])
(delete-record scene-obj name)
(refresh '(draw-current-scene 'dd)))
)))))))))
'*)
;E D I T - S C E N E - O B J E C T
;purpose: Edits a scene-object record
;takes : A record instance.
;returns: The edited record.
;uses : edit-subparts-tree, field-names, flatten
;globals: $novice, $go-up-name, $go-up-levels, $current-simple-cone, $back-up-list
(defun edit-scene-object (instance)
(setq $back-up-list (cons (list 'scene-object (name instance)) $back-up-list))
(setq $go-up-name 'scene-object)
(do nil ((and (not (eq $go-up-name 'scene-object)) (> $go-up-levels 0))
(setq $back-up-list (cdr $back-up-list))
(setq $go-up-levels (1- $go-up-levels)) instance)
(setq $go-up-levels 0)
(let fieldnames ← (cdr (flatten (field-names 'scene-obj)))
do
(writeln)
(writeln '|SCENE-OBJECT | (name instance) '| --f-> | fieldnames)
(writeln '| OBJECT : | ∂scene-obj:object[instance])
(writeln '| SCENE : | ∂scene-obj:scene[instance])
(writeln '| POSITION : | ∂position:symbolic
[∂scene-obj:position[instance]])
(writeln '| ORIENTATION : | ∂rotation:symbolic
[∂scene-obj:orientation[instance]])
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(write '| Go to field G <name> ? : |)
else
(write '| (?;B,G) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G)) then
(caseq instruction
(B (go-back))
(t
(let field ← (readNameOrPosition fieldnames)
do (if field then
(caseq instruction
(G
(cond
((eq field 'object)
∂scene-obj:object[instance] ←
(edit-subparts-tree ∂scene-obj:object[instance]))
((eq field 'scene)
(writeln) (writeln '|SCENE : | ∂scene-obj:scene[instance]
'| (cannot be editted)|))
((eq field 'position)
∂scene-obj:position[instance] ←
(edit-position ∂scene-obj:position[instance]))
((eq field 'orientation)
∂scene-obj:orientation[instance] ←
(edit-orientation ∂scene-obj:orientation[instance]))
))))))))))))
;E D I T - S U B P A R T S - T R E E
;purpose: The only function traversing and changing the subparts tree.
;takes : A node of the subparts tree. It is a prop-list record of type 'object.
;returns: The edited node.
;uses : edit-subparts-tree, edit-record
;globals: $novice, $go-up-name, $go-up-levels, $current-simple-cone, $back-up-list
(defun edit-subparts-tree (object-name)
(setq $back-up-list (cons (list 'object object-name) $back-up-list))
(setq $go-up-name object-name)
(do nil ((and (not (eq $go-up-name object-name)) (> $go-up-levels 0))
(setq $back-up-list (cdr $back-up-list))
(setq $go-up-levels (1- $go-up-levels)) object-name)
(setq $go-up-levels 0)
(let subpartlist ← ∂object:subparts[object-name]
do
(writeln)
(writeln object-name '| --s-> | subpartlist)
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(writeln '| Jump to object G <name>|)
(writeln '| Change this C |)
(writeln '| Add new subpart A <name>|)
(writeln '| Remove subpart R <name>|)
(writeln '| Kill subpart K <name>|)
(write '| Delete subpart D <name> ? : |)
else
(write '| (?;B,G,C,A,R,K,D) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G C A R K D)) then
(caseq instruction
(B (go-back))
(C (edit-record object-name 'object))
(A (let name ← (read) do
∂object:subparts[object-name] ↓
(create-new-object name '(10.0 12.0 15.0))
∂object:affixments[object-name] ↓ (create affixment
sup object-name inf name)
(refresh '(draw-current-scene 'dd))
(edit-record name 'object)))
(G (let name ←
(let input ← (read)
do
(if (numberp input) then
(if (< input 1) then
(writeln '| | input '| is not a valid position|) nil
else
(getAtom input subpartlist))
else input))
do
(if (is? object name) then (edit-subparts-tree name)
else (writeln name '| is not an object|))))
(t
(let name ← (readNameOrPosition subpartlist)
do (if name then
(caseq instruction
(R ∂object:subparts[object-name] ← (delq name subpartlist))
(D ∂object:subparts[object-name] ← (delq name subpartlist)
(for affix ε (find-all affixment inf name) do
(let sup-object ← ∂affixment:sup[affix]
do
∂object:affixments[sup-object] ←
(delete affix
∂object:affixments[sup-object])))
(refresh '(draw-current-scene 'dd)))
(K ∂object:subparts[object-name] ← (delq name subpartlist)
(delete-record object name)
(refresh '(draw-current-scene 'dd)))
))))))))))
;E D I T - F I E L D
;purpose: Edits a field of a record. If it is a list of records, it displays the
; names of its elements an the user chooses, adds, or deletes one.
;takes : A field instance and its type. Example for type: '(record . object)
;returns: The edited field.
;uses : edit-record
;globals: $novice, $go-up-name, $go-up-levels, $current-simple-cone, $back-up-list
(defun edit-field (field-instance field-type sup-record)
(setq $back-up-list (cons (list (cdr field-type) 'fieldlist) $back-up-list))
(setq $go-up-name field-instance)
(do nil ((and (not (eq $go-up-name field-instance)) (> $go-up-levels 0))
(setq $back-up-list (cdr $back-up-list))
(setq $go-up-levels (1- $go-up-levels)) field-instance)
(setq $go-up-levels 0)
(writeln)
(writeln '|This field is a list of the following elements : |
(mapcar 'name field-instance))
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(writeln '| Go to element G <name>|)
(writeln '| Add element A |)
(write '| Delete element D <name> ? : |)
else
(write '| (?;B,G,A,D) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G A D)) then
(caseq instruction
(B (go-back))
(A (let new-record ← (create ≡(cdr field-type))
do
(cond ((eq 'affixment (cdr field-type))
∂affixment:sup[new-record] ← (name sup-record)
∂affixment:inf[new-record] ← (gen-sym))
((eq 'sub-cone (cdr field-type))
∂sub-cone:cone[new-record] ← (name sup-record)
∂sub-cone:sub[new-record] ← (create simple-cone)))
(setq field-instance
(cons (edit-record new-record (cdr field-type))
field-instance))))
(t
(let element ← (readNameOrPosition field-instance)
do (if element then
(caseq instruction
(G (edit-record element (cdr field-type)))
(D (setq field-instance (delq element field-instance))
(case-delete-record (cdr field-type) of $edited-record-types
element)
(putprop $current-simple-cone t 'changed-part)
(refresh '(draw-current-scene 'dd)))
)))))))))
;E D I T - R E C O R D
;purpose: Edits a record. If it is a SIMPLE record, it calls edit-simple,
; otherwise the user chooses a field. If this is a record of type
; 'complex-filler, its value is displayed and changed, otherwise
; edit-field is called.
; If the chosen field is not existent, it is created.
;takes : A record instance and its type. Example for type: 'object
;returns: The edited record.
;uses : edit-simple, edit-field, edit-record, field-names
;globals: $novice, $go-up-name, $go-up-levels, $current-simple-cone, $back-up-list
(defun edit-record (record-instance record-type)
(if (not (atom record-instance)) then (edit-simple record-instance record-type)
else
(let fieldnames ← (delq 'obs-graph (delq 'name (delq 'subparts
(delq 'face0 (delq 'face1 (α-copy (field-names record-type)))))))
do
(setq $back-up-list (cons (list record-type (name record-instance) 'record)
$back-up-list))
(setq $go-up-name record-type)
(do nil ((and (not (eq $go-up-name record-type)) (> $go-up-levels 0))
(setq $back-up-list (cdr $back-up-list))
(setq $go-up-levels (1- $go-up-levels)) record-instance)
(setq $go-up-levels 0)
(if (member 'type fieldnames) then
(let type ← ∂≡record-type:type[record-instance]
do
(if (null type) then (setq fieldnames '(type))
else (setq fieldnames
(cons 'type (cdr (assoc type (assoc record-type $variants))))))))
(writeln)
(writeln record-type '| | (name record-instance) '| --f-> | fieldnames)
(for field-name ε fieldnames do
(let field-instance ← ∂≡record-type:≡field-name[record-instance]
field-type ← (get-field-type field-name record-type)
do (write '| | field-name '| : |)
(if (eq (car field-type) 'list-of-records) then
(writeln (mapcar 'name field-instance))
else (if (equal field-type '(record . complex-filler)) then
(writeln field-instance)
else (writeln (name field-instance))))))
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(write '| Go to field G <name> ? : |)
else
(write '| (?;B,G) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G)) then
(caseq instruction
(B (go-back))
(t
(let field-name ← (readNameOrPosition fieldnames)
do (if field-name then
(let field-instance ← ∂≡record-type:≡field-name[record-instance]
field-type ← (get-field-type field-name record-type)
do
(caseq instruction
(G
(if (eq record-type 'simple-cone) then
(setq $current-simple-cone record-instance))
(cond
((eq field-name 'type)
(let choices ←
(mapcar 'car (cddr (assoc record-type $variants)))
do
(writeln)
(writeln '|Choices : | choices)
(write field-name '| : |)
(setq new (writeread field-instance))
(if (member new choices) then
∂≡record-type:≡field-name[record-instance] ← new
(putprop $current-simple-cone t 'changed-part)
(refresh '(draw-current-scene 'dd)))))
((equal field-type '(record . complex-filler))
(writeln)
(write field-name '| : |)
∂≡record-type:≡field-name[record-instance] ←
(writeread field-instance)
(putprop $current-simple-cone t 'changed-part)
(refresh '(draw-current-scene 'dd)))
(t
∂≡record-type:≡field-name[record-instance] ←
(if (eq (car field-type) 'list-of-records) then
(edit-field field-instance field-type record-instance)
else
(edit-record
(if (null field-instance) then
(create ≡(cdr field-type))
else field-instance)
(cdr field-type))))
))))))))))))))
;E D I T - S I M P L E
;purpose: Edits a SIMPLE record.
; If the chosen field is not existent, it is created.
;takes : A record instance and its type. Example for type: 'affixment
;returns: The edited record.
;uses : edit-record, field-names
;globals: $novice, $go-up-name, $go-up-levels, $current-simple-cone, $back-up-list
(defun edit-simple (instance type)
(let fieldnames ← (cdr (flatten (field-names type)))
do
(setq $back-up-list (cons (list (name instance) type) $back-up-list))
(setq $go-up-name type)
(do nil ((and (not (eq $go-up-name type)) (> $go-up-levels 0))
(setq $back-up-list (cdr $back-up-list))
(setq $go-up-levels (1- $go-up-levels)) instance)
(setq $go-up-levels 0)
(writeln)
(writeln type '| | (name instance) '| --f-> | fieldnames)
(if (eq type 'affixment) then
(writeln '| SUP : | ∂affixment:sup[record-instance])
(writeln '| INF : | ∂affixment:inf[record-instance])
(writeln '| POSITION : | ∂position:symbolic
[∂affixment:position[record-instance]])
(writeln '| ORIENTATION : | ∂rotation:symbolic
[∂affixment:orientation[record-instance]])
else
(writeln '| CONE : | ∂sub-cone:cone[record-instance])
(writeln '| SUB : | ∂sub-cone:sub[record-instance])
(writeln '| POSITION : | ∂position:symbolic
[∂sub-cone:position[record-instance]])
(writeln '| ORIENTATION : | ∂rotation:symbolic
[∂sub-cone:orientation[record-instance]]))
(writeln)
(if $novice then
(writeln '| Go back to B <name>|)
(write '| Go to field G <name> ? : |)
else
(write '| (?;B,G) : |))
(let instruction ← (read)
do
(if (validinstr instruction '(B G)) then
(caseq instruction
(B (go-back))
(t
(let field ← (readNameOrPosition fieldnames)
do (if field then
(caseq instruction
(G
(cond
((eq type 'affixment)
(cond
((eq field 'sup)
(writeln) (writeln '|SUP : | ∂affixment:sup[instance]
'| (cannot be editted)|))
((eq field 'inf)
(writeln) (write '|INF : |)
∂affixment:inf[instance] ←
(let new ← (writeread ∂affixment:inf[instance])
do
(if (not (is? object new)) then
(create-new-object new '(10.0 12.0 15.0))
(putprop $current-simple-cone t 'changed-part)
(refresh '(draw-current-scene 'dd))
(edit-record new 'object))
new))
((eq field 'position)
∂affixment:position[instance] ←
(edit-position ∂affixment:position[instance]))
((eq field 'orientation)
∂affixment:orientation[instance] ←
(edit-orientation ∂affixment:orientation[instance]))))
((eq type 'sub-cone)
(cond
((eq field 'cone)
(writeln) (writeln '|CONE : | ∂sub-cone:cone[instance]
'| (cannot be editted)|))
((eq field 'sub)
∂sub-cone:sub[instance] ←
(edit-record ∂sub-cone:sub[instance] 'simple-cone))
((eq field 'position)
∂sub-cone:position[instance] ←
(edit-position ∂sub-cone:position[instance]))
((eq field 'orientation)
∂sub-cone:orientation[instance] ←
(edit-orientation ∂sub-cone:orientation[instance]))))
))))))))))))